home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zbesk.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.5 KB  |  137 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (defun zbesk (zr zi fnu kode n cyr cyi nz ierr)
  12.   (declare (type double-float zr zi fnu)
  13.            (type (simple-array double-float (*)) cyr cyi)
  14.            (type f2cl-lib:integer4 kode n nz ierr))
  15.   (prog ((k 0) (k1 0) (k2 0) (mr 0) (nn 0) (nuf 0) (nw 0) (aa 0.0) (alim 0.0)
  16.          (aln 0.0) (arg 0.0) (az 0.0) (dig 0.0) (elim 0.0) (fn 0.0) (fnul 0.0)
  17.          (rl 0.0) (r1m5 0.0) (tol 0.0) (ufl 0.0) (bb 0.0))
  18.     (declare
  19.      (type double-float bb ufl tol r1m5 rl fnul fn elim dig az arg aln alim aa)
  20.      (type f2cl-lib:integer4 nw nuf nn mr k2 k1 k))
  21.     (setf ierr 0)
  22.     (setf nz 0)
  23.     (if (and (= zi 0.0f0) (= zr 0.0f0)) (setf ierr 1))
  24.     (if (< fnu 0.0) (setf ierr 1))
  25.     (if (or (< kode 1) (> kode 2)) (setf ierr 1))
  26.     (if (< n 1) (setf ierr 1))
  27.     (if (/= ierr 0) (go end_label))
  28.     (setf nn n)
  29.     (setf tol (max (f2cl-lib:d1mach 4) 1.0e-18))
  30.     (setf k1 (f2cl-lib:i1mach 15))
  31.     (setf k2 (f2cl-lib:i1mach 16))
  32.     (setf r1m5 (f2cl-lib:d1mach 5))
  33.     (setf k (f2cl-lib:int (min (abs k1) (abs k2))))
  34.     (setf elim (* 2.303 (- (* k r1m5) 3.0)))
  35.     (setf k1 (f2cl-lib:int-sub (f2cl-lib:i1mach 14) 1))
  36.     (setf aa (* r1m5 k1))
  37.     (setf dig (min aa 18.0))
  38.     (setf aa (* aa 2.303))
  39.     (setf alim (+ elim (max (- aa) -41.45)))
  40.     (setf fnul (+ 10.0 (* 6.0 (- dig 3.0))))
  41.     (setf rl (+ (* 1.2 dig) 3.0))
  42.     (setf az (zabs zr zi))
  43.     (setf fn (+ fnu (f2cl-lib:int-sub nn 1)))
  44.     (setf aa (/ 0.5 tol))
  45.     (setf bb (* (f2cl-lib:i1mach 9) 0.5))
  46.     (setf aa (min aa bb))
  47.     (if (> az aa) (go label260))
  48.     (if (> fn aa) (go label260))
  49.     (setf aa (f2cl-lib:fsqrt aa))
  50.     (if (> az aa) (setf ierr 3))
  51.     (if (> fn aa) (setf ierr 3))
  52.     (setf ufl (* (f2cl-lib:d1mach 1) 1000.0))
  53.     (if (< az ufl) (go label180))
  54.     (if (> fnu fnul) (go label80))
  55.     (if (<= fn 1.0) (go label60))
  56.     (if (> fn 2.0) (go label50))
  57.     (if (> az tol) (go label60))
  58.     (setf arg (* 0.5 az))
  59.     (setf aln (* (- fn) (f2cl-lib:flog arg)))
  60.     (if (> aln elim) (go label180))
  61.     (go label60)
  62.    label50
  63.     (multiple-value-bind
  64.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  65.          var-11)
  66.         (zuoik zr zi fnu kode 2 nn cyr cyi nuf tol elim alim)
  67.       (declare
  68.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9 var-10
  69.         var-11))
  70.       (setf nuf var-8))
  71.     (if (< nuf 0) (go label180))
  72.     (setf nz (f2cl-lib:int-add nz nuf))
  73.     (setf nn (f2cl-lib:int-sub nn nuf))
  74.     (if (= nn 0) (go label100))
  75.    label60
  76.     (if (< zr 0.0) (go label70))
  77.     (multiple-value-bind
  78.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
  79.         (zbknu zr zi fnu kode nn cyr cyi nw tol elim alim)
  80.       (declare
  81.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 var-10))
  82.       (setf nw var-7))
  83.     (if (< nw 0) (go label200))
  84.     (setf nz nw)
  85.     (go end_label)
  86.    label70
  87.     (if (/= nz 0) (go label180))
  88.     (setf mr 1)
  89.     (if (< zi 0.0) (setf mr -1))
  90.     (multiple-value-bind
  91.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  92.          var-11 var-12 var-13)
  93.         (zacon zr zi fnu kode mr nn cyr cyi nw rl fnul tol elim alim)
  94.       (declare
  95.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9 var-10
  96.         var-11 var-12 var-13))
  97.       (setf nw var-8))
  98.     (if (< nw 0) (go label200))
  99.     (setf nz nw)
  100.     (go end_label)
  101.    label80
  102.     (setf mr 0)
  103.     (if (>= zr 0.0) (go label90))
  104.     (setf mr 1)
  105.     (if (< zi 0.0) (setf mr -1))
  106.    label90
  107.     (multiple-value-bind
  108.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  109.          var-11)
  110.         (zbunk zr zi fnu kode mr nn cyr cyi nw tol elim alim)
  111.       (declare
  112.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9 var-10
  113.         var-11))
  114.       (setf nw var-8))
  115.     (if (< nw 0) (go label200))
  116.     (setf nz (f2cl-lib:int-add nz nw))
  117.     (go end_label)
  118.    label100
  119.     (if (< zr 0.0) (go label180))
  120.     (go end_label)
  121.    label180
  122.     (setf nz 0)
  123.     (setf ierr 2)
  124.     (go end_label)
  125.    label200
  126.     (if (= nw -1) (go label180))
  127.     (setf nz 0)
  128.     (setf ierr 5)
  129.     (go end_label)
  130.    label260
  131.     (setf nz 0)
  132.     (setf ierr 4)
  133.     (go end_label)
  134.    end_label
  135.     (return (values nil nil nil nil nil nil nil nz ierr))))
  136.  
  137.